home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / compare.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  26.0 KB  |  611 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ;;; compare utility 6/20/90
  3. ;;; written by Laura Bagnall Linden of TERC
  4.  
  5. ;;;;;;;
  6. ;;; Change history
  7. ;;;
  8. ;;; 04/28/93 mwp Release
  9. ;;; 08/11/92 bill Michael Travers' fix to select-diff-buffer
  10. ;;; ------------  2.0
  11. ;;; 01/22/91 bill Add compare-files-to-buffer, keep-first-version, keep-second-version
  12. ;;; Ported to MCL2.0 by alanr Saturday September 22,1990 5:36pm
  13. ;;;
  14. ;;;;;;
  15.  
  16.  
  17. (in-package :ccl)
  18.  
  19. (locally (declare (optimize (speed 3) (safety 0)))
  20.  
  21. (def-load-pointers disable-dead-keys ()
  22.   (set-dead-keys nil))                  ; allow typing <Meta>-N, etc.
  23.  
  24. (defvar *show-matched-text* t
  25.   "True if matching text should be displayed")
  26. (defvar *matched-lines-style* '("monaco" :plain 9)
  27.   "Font list for lines in both files")
  28. (defvar *file1-lines-style* '("monaco" :bold :italic 9)
  29.   "Font list for lines found only in file 1")
  30. (defvar *file2-lines-style* '("monaco" :plain :bold 9)
  31.   "Font list for lines found only in file 2")
  32.  
  33. (comtab-set-key *control-x-comtab* #\D #'(lambda(w) (eval-enqueue `(compare-buffer-to-file ,w)))
  34.                 "Compare top *fred-window* to selected file")
  35.  
  36. (comtab-set-key *control-x-comtab* #\d #'(lambda(w) (eval-enqueue `(compare-buffer-to-other-buffer ,w)))
  37.                 "Compare top *fred-window* to selected other buffer")
  38.  
  39. (comtab-set-key *control-x-comtab* #\c 'clear-fonts
  40.                 "Put all text in buffer in plain font")
  41.  
  42. (comtab-set-key *comtab* '(:meta #\n) 'goto-next-difference 
  43.                 "Move cursor to next difference in window")
  44.  
  45. (comtab-set-key *comtab* '(:meta #\p) 'goto-previous-difference
  46.                 "Move cursor to previous difference in window")
  47.  
  48. ; Undo works with these two commands.
  49. ; Also, these two will toggle if invoked with no intervening keystrokes.
  50. (comtab-set-key *comtab* '(:meta #\j) 'keep-first-version
  51.                 "Keep the first version of this difference")
  52.  
  53. (comtab-set-key *comtab* '(:meta #\k) 'keep-second-version
  54.                 "Keep the second version of this difference")
  55.  
  56. (comtab-set-key *comtab* '(:control :meta #\j) 'keep-both-versions
  57.                 "Keep both versions of this difference")
  58.  
  59. (comtab-set-key *control-x-comtab* '(:control #\j) 'keep-all-first-versions
  60.                 "Keep the first versions of all unselected changes in the buffer")
  61.  
  62. (comtab-set-key *control-x-comtab* '(:control #\k) 'keep-all-second-versions
  63.                 "Keep the second versions of all unselected changes in the buffer")
  64.  
  65. ;;; This is the data structure used by the comparison algorithm.  A buffered stream
  66. ;;; is a list of lines taken from a stream.  The list is used in a first-in, first-out
  67. ;;; fashion.  HEAD-PTR points to the first element of the list, and TAIL-PTR points to
  68. ;;; the last element of the list, allowing elements to efficiently be added to the
  69. ;;; end of the list.  The algorithm alternately tests each element in the buffer against 
  70. ;;; all of the elements in the other buffer.  TESTED-PTR points to the last entry in the 
  71. ;;; buffer which has been tested.  COUNT is the number of entries which have been tested,
  72. ;;; and is always equal to (1+ (- (length head-ptr) (length tested-ptr))).  Once a match
  73. ;;; has been found, MATCHED-PTR is used to point to the beginning of the match.  The 
  74. ;;; buffered-stream should always have at least one line in the buffer, unless the
  75. ;;; underlying stream is essmpty.
  76.  
  77. (defstruct (bstream (:print-function print-bstream))
  78.   (head-ptr '())        ;pointer to start of queue
  79.   (tested-ptr '())        ;pointer to last tested entry in queue
  80.   (tail-ptr '())        ;pointer to end of queue
  81.   (matched-ptr '())             ;pointer to start of match
  82.   (count 0)            ;number of tested entries in queue
  83.   stream)            ;stream that the queue is buffering.
  84.  
  85. (defun make-buffered-stream (&rest args)
  86.   (declare (dynamic-extent args))
  87.   (apply 'make-bstream args))
  88.  
  89. (defun print-bstream (bstream stream depth)
  90.   (declare (ignore depth))
  91.   (format stream "[~S;~S;~S;~S;~S]"
  92.           (bstream-head-ptr bstream)
  93.           (bstream-tested-ptr bstream)
  94.           (bstream-tail-ptr bstream)
  95.           (bstream-matched-ptr bstream)
  96.           (bstream-count bstream)))
  97.  
  98. (defun init-buffered-stream (line stream)
  99.   (if (eq line :eof)
  100.     (make-buffered-stream :stream stream)
  101.     (let ((new-pair (cons line nil)))
  102.       (make-buffered-stream :head-ptr new-pair
  103.                             :tested-ptr new-pair
  104.                             :tail-ptr new-pair
  105.                             :count 1
  106.                             :stream stream))))
  107.  
  108. (defun bstream-at-eof? (bstream)
  109.   (empty-queue? bstream))                           
  110.  
  111. (defun at-end? (bstream)
  112.   (eq (bstream-head-ptr bstream) (bstream-tail-ptr bstream)))
  113.  
  114. ;;; this is not to be used by functions external to the bstream abstraction.
  115. (defun empty-queue? (queue)
  116.   (null (bstream-head-ptr queue)))
  117.  
  118. (defun first-entry (bstream)
  119.   (if (empty-queue? bstream)
  120.       (error "first-entry called with an empty bstream" bstream) 
  121.       (car (bstream-head-ptr bstream))))
  122.  
  123. (defun bstream-insert (line bstream &aux (new-pair (cons line nil)))
  124.   (cond ((empty-queue? bstream) (error "this shouldn't happen"))
  125.         (t (rplacd (bstream-tail-ptr bstream) new-pair)
  126.            (setf (bstream-tail-ptr bstream) new-pair)
  127.            bstream)))
  128.  
  129. (defun bump-tested-ptr (bstream)
  130.   (if (null (cdr (bstream-tested-ptr bstream))) 
  131.     (error "Can't increment tested pointer past end of buffer"))
  132.   (setf (bstream-tested-ptr bstream) (cdr (bstream-tested-ptr bstream)))
  133.   (incf (bstream-count bstream)))
  134.  
  135. ;;; delete entry from bstream buffer, and if that's the last one, prefetch the next
  136. ;;; line from the stream, if there is one.
  137. (defun delete-and-prefetch (bstream)
  138.   (when (eq (bstream-head-ptr bstream)
  139.             (bstream-tail-ptr bstream))
  140.     (buffer-next-line bstream))
  141.   (delete-queue bstream)
  142.   )
  143.  
  144. ;;; this is not to be used by functions external to the bstream abstraction.
  145. (defun delete-queue (queue)
  146.   (cond ((empty-queue? queue)
  147.          (error "Delete called with an empty queue" queue))
  148.         (t (when (and (eq (bstream-head-ptr queue) (bstream-tested-ptr queue))
  149.                       (not (eq (bstream-head-ptr queue) (bstream-tail-ptr queue))))
  150.              (bump-tested-ptr queue))
  151.            (setf (bstream-head-ptr queue) (cdr (bstream-head-ptr queue)))
  152.            (decf (bstream-count queue))
  153.            queue)))
  154.  
  155. (defun flush-bstream (bstream output)
  156.   (labels ((flush-queue ()
  157.                         (cond ((empty-queue? bstream)
  158.                                (stream-copy-until-eof (bstream-stream bstream)))
  159.                               (t (insert-line output(first-entry bstream))
  160.                                  (delete-queue bstream)
  161.                                  (flush-queue))))
  162.            (stream-copy-until-eof (stream)
  163.                                   (unless (stream-eofp stream)
  164.                                     (insert-line output (read-line stream))
  165.                                     (stream-copy-until-eof stream))))
  166.     (flush-queue)))
  167.  
  168.  
  169.  
  170. ;;; This function is the guts of the program.  It uses the algorithm described in 
  171. ;;; MPW to compare two input streams (stream1 and stream2) and outputs the result 
  172. ;;; onto output-stream.  The input streams must support the operation READ-LINE.
  173. ;;; The output stream must support the operations START-DIFFERENCE-ONE,
  174. ;;; START-DIFFERENCE-TWO, START-MATCHED-TEXT, INSERT-LINE, and PRINT-LEGEND.  
  175.  
  176. ;;; Description of algorithm (taken verbatim from MPW Compare facility)
  177.  
  178. ;;; Both files are read and compared line for line.  As soon as a mismatch is found,
  179. ;;; the two mismatched lines are stored in two stacks, one for each file.  Lines are 
  180. ;;; then read alternately (starting from the next input line in file2) until a match 
  181. ;;; is found to put the files back in synchronization.  If such a match is found, 
  182. ;;; Compare writes the mismatched lines to standard output.
  183.  
  184. ;;; Files are considered resynchronized when a certain number of lines in the two 
  185. ;;; stacks exactly match.  By default, the number of lines, called the grouping factor, 
  186. ;;; is defined by the formula (truncate (+ (* 2.0 (log M 10)) 2.0)) where M is the 
  187. ;;; number of lines saved in each stack so far.  This definition requires more lines 
  188. ;;;to be the same after larger mismatches.
  189.  
  190. (defun compare (stream1 stream2 output-stream)
  191.   (declare (optimize (speed 3) (safety 0)) (inline iter))
  192.   (let ((bstream1 (init-buffered-stream (read-line stream1 nil :eof) stream1))
  193.         (bstream2 (init-buffered-stream (read-line stream2 nil :eof) stream2)))
  194.     (labels ((iter (at-eof? diff-count)
  195.                    (cond ((bstream-at-eof? bstream1)
  196.                           (cond ((bstream-at-eof? bstream2) diff-count)
  197.                                 (t (unless at-eof?
  198.                                      (start-difference-two output-stream))
  199.                                    (insert-line output-stream (first-entry bstream2))
  200.                                    (delete-and-prefetch bstream2)
  201.                                    (iter t (if at-eof? diff-count (1+ diff-count))))))
  202.                          ((bstream-at-eof? bstream2)
  203.                           (unless at-eof? (start-difference-one output-stream))
  204.                           (insert-line output-stream (first-entry bstream1))
  205.                           (delete-and-prefetch bstream1)
  206.                           (iter t (if at-eof? diff-count (1+ diff-count))))
  207.                          ((string= (first-entry bstream1) (first-entry bstream2))
  208.                           (when *show-matched-text*
  209.                             (insert-line output-stream (first-entry bstream1)))
  210.                           (delete-and-prefetch bstream1)
  211.                           (delete-and-prefetch bstream2)
  212.                           (iter nil diff-count))
  213.                          (t (resynchronize bstream1 bstream2 output-stream)
  214.                             (iter nil (1+ diff-count))))))
  215.       (iter nil 0))))
  216.  
  217. (defun resynchronize (bstream1 bstream2 output)
  218.   (cond ((match bstream1 bstream2)
  219.          ;;(format t "bstream1: ~S,~%bstream2: ~S~%" bstream1 bstream2)
  220.          (start-difference-one output)
  221.          (output-differences bstream1 output)
  222.          (start-difference-two output)
  223.          (output-differences bstream2 output)
  224.          ;;(format t "bstream1: ~S,~%bstream2: ~S~%" bstream1 bstream2)
  225.          (start-matched-text output)
  226.          (output-matched-text bstream1 bstream2 output)
  227.          ;;(format t "bstream1: ~S,~%bstream2: ~S~%" bstream1 bstream2)
  228.          )
  229.         (t (start-difference-one output)
  230.            (flush-bstream bstream1 output)
  231.            (start-difference-two output)
  232.            (flush-bstream bstream2 output))
  233.         ))
  234.  
  235. (defun output-differences (bstream output)
  236.   (declare (optimize (speed 3) (safety 0)) (inline loop))
  237.   (labels ((loop (l)
  238.                  (cond ((eq l (bstream-matched-ptr bstream)) bstream)
  239.                        (t (insert-line output(first-entry bstream))
  240.                           (delete-queue bstream)
  241.                           (loop (cdr l))))))
  242.     (loop (bstream-head-ptr bstream))))
  243.  
  244. (defun output-matched-text (bstream1 bstream2 output)
  245.   (declare (optimize (speed 3) (safety 0)) (inline loop))
  246.   (labels ((loop ()
  247.                  (cond ((at-end? bstream1) (buffer-next-line bstream1))
  248.                        ((at-end? bstream2) (buffer-next-line bstream2))
  249.                        ((string/= (first-entry bstream1) (first-entry bstream2))
  250.                         (error "This shouldn't happen"))
  251.                        (t (when *show-matched-text*
  252.                             (insert-line output (first-entry bstream1)))
  253.                           (delete-queue bstream1)
  254.                           (delete-queue bstream2)
  255.                           (loop)))))
  256.     (loop)))
  257.                        
  258. ;;; Given two buffered streams, bstream1 and bstream2, tries to match the first 
  259. ;;; untested entry in bstream1 against all the entries in bstream2.  If it succeeds,
  260. ;;; then it outputs the entries already tested as differences, otherwise, it repeats
  261. ;;; the process with the next line in bstream2.
  262. (defun match (bstream1 bstream2)
  263.   (declare (optimize (speed 3) (safety 0)) (inline loop))
  264.   (let ((first-untested-entry (next-entry (bstream-tested-ptr bstream1) bstream1)))
  265.     (labels ((loop (entry-to-compare count)
  266.                    (cond ((null first-untested-entry) nil)
  267.                          ((zerop count) 
  268.                           (bump-tested-ptr bstream1)
  269.                           (match bstream2 bstream1))
  270.                          ((match-entry first-untested-entry bstream1
  271.                                        entry-to-compare bstream2
  272.                                        (group-factor (bstream-count bstream1)))
  273.                           (setf (bstream-matched-ptr bstream1) first-untested-entry)
  274.                           (setf (bstream-matched-ptr bstream2) entry-to-compare)
  275.                           t)
  276.                          (t (loop (next-entry entry-to-compare bstream2) (1- count))))))
  277.       (loop (bstream-head-ptr bstream2) (bstream-count bstream2))
  278.       )))
  279.  
  280. (defun group-factor (m) 
  281.   (check-type m (integer 1 *) "a positive integer")
  282.   (truncate (+ (* 2.0 (log M 10)) 2.0)))
  283.  
  284. (defun match-entry (ptr1 bstream1 ptr2 bstream2 depth)
  285.   (cond ((zerop depth) t)
  286.         ((or (null ptr1) (null ptr2)) nil)
  287.         ((string/= (car ptr1) (car ptr2)) nil)
  288.         (t (match-entry (next-entry ptr1 bstream1)
  289.                         bstream1
  290.                         (next-entry ptr2 bstream2)
  291.                         bstream2
  292.                         (1- depth)))
  293.     ))
  294.  
  295. (defun next-entry (ptr bstream)
  296.   (if (null (cdr ptr))
  297.     (buffer-next-line bstream)
  298.     (cdr ptr)))
  299.  
  300. (defun buffer-next-line (bstream)
  301.   (let ((line (read-line (bstream-stream bstream) nil :eof)))
  302.     (unless (eq line :eof)
  303.       (bstream-insert line bstream)
  304.       (bstream-tail-ptr bstream))))
  305.  
  306. (defclass difference-output-stream (stream) 
  307.   ((stream :accessor stream :initarg :stream :initform *standard-output*)))
  308.  
  309. (defmethod start-difference-one ((s difference-output-stream))
  310.   (format (stream s) "*** Start of difference in first file ***~%"))
  311.  
  312. (defmethod start-difference-two ((s difference-output-stream))
  313.   (format (stream s) "*** Start of difference in second file ***~%"))
  314.  
  315. (defmethod start-matched-text ((s difference-output-stream))
  316.   (format (stream s) "*** End of differences ***~%"))
  317.  
  318. (defmethod insert-line ((s difference-output-stream) line)
  319.   (stream-write-string (stream s) line 0 (length line))
  320.   (terpri (stream s)))
  321.  
  322. (defmethod print-legend ((s difference-output-stream) name1 name2)
  323.   (format (stream s) "Comparison of ~A with ~A~%" name1 name2))
  324.  
  325. (defmethod stream-close ((s difference-output-stream))
  326.   (close (stream s)))
  327.  
  328. (defun compare-files (file1 file2 &optional filename)
  329.   (with-open-file (s1 file1)
  330.     (with-open-file (s2 file2)
  331.       (with-open-stream
  332.         (output (make-instance 'difference-output-stream
  333.                                :stream (if filename 
  334.                                          (open filename :direction :output
  335.                                                :if-exists :append
  336.                                                :if-does-not-exist :create)
  337.                                          *standard-output*))) 
  338.         (print-legend output file1 file2)
  339.         (format t "~D differences found" (compare s1 s2 output))))))
  340.  
  341. ;;; The next bit of code will define a subclass FRED-DIFF-WINDOW which inherits both 
  342. ;;; from DIFFERENCE-OUTPUT-STREAM and FRED-WINDOW.
  343.  
  344. (defclass fred-diff-window (fred-window difference-output-stream) () 
  345.   (:default-initargs :window-title "Source Compare"))
  346.  
  347. (defun difference-marks (w)
  348.   (buffer-getprop (fred-buffer w) 'difference-marks nil))
  349.  
  350. (defun (setf difference-marks) (value w)
  351.   (buffer-putprop (fred-buffer w) 'difference-marks value))
  352.  
  353. (defmethod start-difference-one ((w fred-diff-window))
  354.   (setf (difference-marks w)
  355.         (nconc (difference-marks w)
  356.                (list (list (make-mark (fred-buffer w)
  357.                                       (buffer-position (fred-buffer w)) t)
  358.                            nil
  359.                            nil))))
  360.   (buffer-set-font-spec (fred-buffer w) *file1-lines-style*)
  361.   (set-mark (fred-display-start-mark w) (fred-buffer w))
  362.   (window-update-event-handler w))
  363.  
  364. (defmethod start-difference-two ((w fred-diff-window))
  365.   (let* ((last (last (difference-marks w)))
  366.          (buf (fred-buffer w))
  367.          (mark (make-mark buf (buffer-position buf) t)))
  368.     (if (and last (null (second (car last))))
  369.       (setf (second (car last)) mark)
  370.       (let ((new (list (list mark mark nil))))
  371.         (if last
  372.           (setf (cdr last) new)
  373.           (setf (difference-marks w) new))))
  374.     (buffer-set-font-spec buf *file2-lines-style*)))
  375.  
  376. (defmethod start-matched-text ((w fred-diff-window))
  377.   (let ((last (car (last (difference-marks w)))))
  378.     (when (and last (null (third last)))
  379.       (let* ((buf (fred-buffer w))
  380.              (mark (make-mark buf (buffer-position buf) t)))
  381.         (unless (second last)
  382.           (setf (second last) mark))
  383.         (setf (third last) mark))))
  384.   (buffer-set-font-spec (fred-buffer w) *matched-lines-style*))
  385.  
  386. (defmethod insert-line ((w fred-diff-window) text)
  387.   (ed-insert-with-style w text nil)
  388.   (terpri w)
  389. ;  (window-update-event-handler w)
  390.   )
  391.  
  392. (defmethod print-legend ((w fred-diff-window) name1 name2)
  393.   (buffer-set-font-spec (fred-buffer w) *file1-lines-style*)
  394.   (ed-insert-with-style w
  395.    (format nil "; THIS IS IN «~a», but not «~a».~%" name1 name2)
  396.    nil)
  397.   (buffer-set-font-spec (fred-buffer w) *file2-lines-style*)
  398.   (ed-insert-with-style w
  399.    (format nil "; THIS IS IN «~a», but not «~a».~%"
  400.            name2 name1)
  401.    nil)
  402.   (buffer-set-font-spec (fred-buffer w) *matched-lines-style*)    
  403.   (ed-insert-with-style w
  404.    (format nil "; «»«»«»«»«»«»«»«»«»«»«»«»«»«»~%~%")
  405.    nil)
  406.   (window-update-event-handler w))
  407.  
  408. (defmacro with-mark ((name buffer position) &body body)
  409.   `(let ((,name (make-mark ,buffer ,position)))
  410.      ,@body))
  411.  
  412. (defmacro with-fred-stream ((stream-var fred-window) &body body)
  413.   `(let ((,stream-var (window-selection-stream ,fred-window 0 t)))
  414.      ,@body))
  415.  
  416. (defun compare-buffer-to-file (f1)
  417.   (let ((f2 (choose-file-dialog :button-string "File 2")))
  418.     (when f2
  419.       (with-fred-stream (stream1 f1)
  420.         (with-open-file (stream2 f2)
  421.           (let ((output (make-instance 'fred-diff-window)))
  422.             (print-legend output (window-filename f1) f2)
  423.             (set-mini-buffer output "Getting diffs …")
  424.             (set-mini-buffer output (format nil "~D differences found" 
  425.                                             (compare stream1 stream2 output)))
  426.             (start-matched-text output)   ; ensure last difference-mark is complete
  427.             (set-mark (fred-buffer output)  0)
  428.             (window-update-event-handler output)
  429.             (window-set-not-modified output)
  430.             ))))))
  431.  
  432. (defun compare-buffer-to-other-buffer (f1)
  433.   (let ((f2 (select-diff-buffer f1)))
  434.     (when f2
  435.       (with-fred-stream (stream1 f1)
  436.         (with-fred-stream (stream2 f2)
  437.           (let ((output (make-instance 'fred-diff-window)))
  438.             (print-legend output (window-filename f1) (window-filename f2))
  439.             (set-mini-buffer output "Getting diffs …")
  440.             (set-mini-buffer output (format nil "~D differences found"
  441.                                             (compare stream1 stream2 output)))
  442.             (start-matched-text output)   ; ensure last difference-mark is complete
  443.             (set-mark (fred-buffer output) 0)
  444.             (window-update-event-handler output)
  445.             (window-set-not-modified output)))))))
  446.  
  447. (defun compare-files-to-buffer (from-file to-file &optional (output-file to-file))
  448.   (with-open-file (stream1 from-file)
  449.     (with-open-file (stream2 to-file)
  450.       (let ((*show-matched-text* t)
  451.             (output (make-instance 'fred-diff-window :window-show nil)))
  452.         (set-window-filename output output-file)
  453.         (view-restore-position output)
  454.         (window-show output)
  455. ;        (print-legend output from-file to-file)
  456.         (set-mini-buffer output "Getting diffs …")
  457.         (let ((diffs (compare stream1 stream2 output)))
  458.           (when (eql 0 diffs)
  459.             (window-set-not-modified output) 
  460.             (window-close output)
  461.             (return-from compare-files-to-buffer 0))
  462.           (start-matched-text output)   ; ensure last difference-mark is complete
  463.           (set-mini-buffer output (format nil "~D differences found" diffs))
  464.           (set-mark (fred-buffer output)  0)
  465.           (goto-next-difference output)
  466.           (window-show-cursor output)
  467.           (values diffs output))))))
  468.  
  469. (defun select-diff-buffer (current)
  470.   (car (select-item-from-list
  471.         (delete-if #'(lambda (w) (typep w 'listener))
  472.                    (remove current
  473.                            (windows :class 'fred-window
  474.                                     :include-invisibles t)))
  475.         :table-print-function #'(lambda (w stream)
  476.                                   (princ (or (window-filename w)
  477.                                              (window-title w))
  478.                                          stream))
  479.         :window-title (format  nil "Compare \"~A\" to:"
  480.                                (or (window-filename current)
  481.                                    (window-title current))))))
  482.  
  483. (defmethod clear-fonts ((w fred-window))
  484.   (buffer-set-font-spec (fred-buffer w) '(:plain) 
  485.                         0 (buffer-size (fred-buffer w))))
  486.  
  487. (defun find-next-difference (w &optional (pos (fred-buffer w)))
  488.   (unless (integerp pos) (setq pos (buffer-position pos)))
  489.   (let (mark)
  490.     (dolist (marks (difference-marks w))
  491.       (when (and (setq mark (car marks))
  492.                  (< pos (buffer-position mark)))
  493.         (return mark)))))
  494.  
  495. (defun find-previous-difference (w &optional (pos (fred-buffer w)))
  496.   (unless (integerp pos) (setq pos (buffer-position pos)))
  497.   (let (mark last-mark)
  498.     (dolist (marks (difference-marks w))
  499.       (when (and (setq mark (car marks))
  500.                  (<= pos (buffer-position mark)))
  501.         (return last-mark))
  502.       (setq last-mark mark))))
  503.  
  504. (defun goto-next-difference (w &optional quiet-p)
  505.   (let ((next-mark (find-next-difference w)))
  506.     (if next-mark
  507.       (set-mark (fred-buffer w) next-mark)
  508.       (progn (unless quiet-p (ed-beep)) nil))))
  509.  
  510. (defun goto-previous-difference (w &optional quiet-p)
  511.   (let ((next-mark (find-previous-difference w)))
  512.     (if next-mark
  513.       (set-mark (fred-buffer w) next-mark)
  514.       (progn (unless quiet-p (ed-beep)) nil))))
  515.  
  516. (defun difference-range (w &optional (pos (fred-buffer w)))
  517.   (unless (integerp pos) (setq pos (buffer-position pos)))
  518.   (dolist (marks (difference-marks w))
  519.     (when (and (first marks)
  520.                (>= pos (buffer-position (first marks)))
  521.                (<= pos (buffer-position (third marks))))
  522.       (return (values (buffer-position (first marks))
  523.                       (buffer-position (second marks))
  524.                       (buffer-position (third marks))
  525.                       marks)))))
  526.  
  527. (defun keep-first-version (w)
  528.   (keep-version w #'(lambda (buf start middle end)
  529.                       (declare (ignore end))
  530.                       (buffer-substring buf start middle))))
  531.  
  532. (defun keep-second-version (w)
  533.   (keep-version w #'(lambda (buf start middle end)
  534.                       (declare (ignore start))
  535.                       (buffer-substring buf middle end))))
  536.  
  537. (defun keep-both-versions (w)
  538.   (keep-version w #'(lambda (buf start middle end)
  539.                       (declare (ignore middle))
  540.                       (buffer-substring buf start end))))
  541.  
  542. (defun keep-all-first-versions (w)
  543.   (set-mark (fred-buffer w) 0)
  544.   (setq *last-command* nil)
  545.   (when (difference-range w) (keep-first-version w))
  546.   (loop
  547.     (unless (goto-next-difference w t) (return))
  548.     (setq *last-command* nil)
  549.     (keep-first-version w)))
  550.  
  551. (defun keep-all-second-versions (w)
  552.   (set-mark (fred-buffer w) 0)
  553.   (setq *last-command* nil)
  554.   (when (difference-range w) (keep-second-version w))
  555.   (loop
  556.     (unless (goto-next-difference w t) (return))
  557.     (setq *last-command* nil)
  558.     (keep-second-version w)))
  559.  
  560. (defun keep-version (w keep-string-function)
  561.   (let ((show-cursor-p nil))
  562.     (if (and (eq 'keep-version *last-command*)
  563.              (window-can-do-operation w 'undo))
  564.       (undo w))
  565.     (setq show-cursor-p t)
  566.     (multiple-value-bind (start middle end marks) (difference-range w)
  567.       (if (not start)
  568.         (ed-beep)
  569.         (let* ((buf (fred-buffer w))
  570.                (undo-string (buffer-substring buf start end))
  571.                (undo-style (buffer-get-style buf start end))
  572.                (redo-string (funcall keep-string-function buf start middle end)))
  573.           (labels ((undo ()
  574.                          (buffer-delete buf start (+ start (length redo-string)))
  575.                          (buffer-insert-with-style buf undo-string undo-style start)
  576.                          (setf (first marks) (make-mark buf start t)
  577.                                (second marks) (make-mark buf middle)
  578.                                (third marks) (make-mark buf end))
  579.                          (set-mark buf start)
  580.                          (when show-cursor-p (window-show-cursor w))
  581.                          (set-fred-last-command w nil)
  582.                          (setup-undo w #'redo "Redo"))
  583.                    (redo ()
  584.                          (buffer-delete buf start end)
  585.                          (buffer-insert buf redo-string start)
  586.                          (setf (first marks) nil)
  587.                          (set-mark buf start)
  588.                          (when show-cursor-p (window-show-cursor w))
  589.                          (set-fred-last-command w 'keep-version)
  590.                          (setup-undo w #'undo "Undo")))
  591.             (redo)))))))
  592.                             
  593.  );                      
  594.                           
  595.   
  596.  
  597.  
  598. ;;; *****  List of things to do.  *****
  599.  
  600. ;;; What I would like to do is not to do any display until the first difference is found,
  601. ;;; and if no differences exist, than not to do any display.  However, this would mean
  602. ;;; that the files would have to be reread from the beginning if differences are found.
  603. ;;; Thus, I am choosing the alternative which is to go ahead and create the output 
  604. ;;; window, and if the file are the same, then close the output-stream and throw control
  605. ;;; back to the calling function which will display some appropriate message stating that
  606. ;;; no differences were found.  
  607. ;;; [Note: (ask random-window (window-close)) makes windows go away
  608.  
  609.  
  610.  
  611. (provide :compare)